Acorn User: China/Acorn User China CD-ROM (UK) (Disc B)/Acorn User China CD-ROM (UK) (Disc B).bin/STUTTGART/LANG/GOFER/!Gofer_preludes_gcwmin

Text File | 1994-05-20 | 18.1 KB | 628 lines

--         __________   __________   __________   __________   ________
--        /  _______/  /  ____   /  /  _______/  /  _______/  /  ____  \
--       /  / _____   /  /   /  /  /  /______   /  /______   /  /___/  /
--      /  / /_   /  /  /   /  /  /  _______/  /  _______/  /  __   __/
--     /  /___/  /  /  /___/  /  /  /         /  /______   /  /  \  \
--    /_________/  /_________/  /__/         /_________/  /__/    \__\
--
--    Functional programming environment, Version 2.28
--    Copyright Mark P Jones 1991-1993.
--
--    Minimal Gofer prelude for experimentation with different approaches
--    to standard operations.
--
--   Any Gofer prelude file should typically include at least the following
--   definitions:

infixr 5 :
infixr 3 &&
infixr 2 ||

(&&), (||)     :: Bool -> Bool -> Bool
False && _      = False     -- (&&) and (||) names predefined in Gofer
True  && x      = x
False || x      = x
True  || _      = True

flip           :: (a -> b -> c) -> b -> a -> c
flip  f x y     =  f y x

-- Primitives -----------------------------------------------------------

primitive error "primError" :: String -> a

-- End of minimal prelude ----------------------------------------------

primitive strict "primStrict" :: (a -> b) -> a -> b

-- Format primitives ----------------------------------------------------

primitive primPrint "primPrint"  :: Int -> a -> String -> String
primitive primShowsInt "primShowsInt" :: Int -> Int -> String -> String
primitive primShowsFloat "primShowsFloat" ::
                     Int -> Float -> String -> String

-- Character primitives -------------------------------------------------

primitive primEqChar   "primEqChar",
          primLeChar   "primLeChar"  :: Char -> Char -> Bool
primitive ord "primCharToInt" :: Char -> Int
primitive chr "primIntToChar" :: Int -> Char

-- Integer primitives --------------------------------------------------

primitive primEqInt    "primEqInt",
          primLeInt    "primLeInt"   :: Int -> Int -> Bool
primitive primPlusInt  "primPlusInt",
          primMinusInt "primMinusInt",
          primDivInt   "primDivInt",
          primMulInt   "primMulInt"  :: Int -> Int -> Int
primitive primNegInt   "primNegInt"  :: Int -> Int
primitive quot   "primQuotInt",
          rem    "primRemInt",
          mod    "primModInt"    :: Int -> Int -> Int


-- Float primitives ---------------------------------------------------

primitive primEqFloat    "primEqFloat",
          primLeFloat    "primLeFloat"    :: Float -> Float -> Bool
primitive primPlusFloat  "primPlusFloat",
          primMinusFloat "primMinusFloat",
          primDivFloat   "primDivFloat",
          primMulFloat   "primMulFloat"   :: Float -> Float -> Float
primitive primNegFloat   "primNegFloat"   :: Float -> Float
primitive primIntToFloat "primIntToFloat" :: Int -> Float
primitive truncate "primFloatToInt" :: Float -> Int

-- Trigonometric primitives ------------------------------------

primitive sin  "primSinFloat",  asin  "primAsinFloat",
          cos  "primCosFloat",  acos  "primAcosFloat",
          tan "primTanFloat",  atan  "primAtanFloat",
          primLogFloat  "primLogFloat",  log10 "primLog10Float",
          primExpFloat  "primExpFloat",  sqrt  "primSqrtFloat"
                            :: Float -> Float
primitive atan2    "primAtan2Float" :: Float -> Float -> Float

-- IO ------------------------------------------------------------

stdin         =  "stdin"
stdout        =  "stdout"
stderr        =  "stderr"
stdecho       =  "stdecho"

{- The Dialogue, Request, Response and IOError datatypes are now built-in:
data Request  =  -- file system requests:
                ReadFile      String
              | WriteFile     String String
              | AppendFile    String String
                 -- channel system requests:
              | ReadChan      String
              | AppendChan    String String
                 -- environment requests:
              | Echo          Bool
              | GetArgs
              | GetProgName
              | GetEnv        String

data Response = Success
              | Str     String
              | Failure IOError
              | StrList [String]

data IOError  = WriteError   String
              | ReadError    String
              | SearchError  String
              | FormatError  String
              | OtherError   String

type Dialogue    =  [Response] -> [Request]
-}

run             :: (String -> String) -> Dialogue
run f ~(Success : ~(Str kbd : _))
             = [Echo False, ReadChan "stdin", AppendChan "stdout" (f kbd)]

primitive primFopen "primFopen" :: String -> a -> (String -> a) -> a

openfile        :: String -> String
openfile f       = primFopen f (error ("can't open file "++f)) id

--- Fixities ------------------------------------------------------------

infixl 9 !!
infixr 9 .
infixr 8 ^
infixl 7 *, :/, /
infix  7  `quot`, `rem`, `mod`
infixl 6 +, -, :+!
infixr 5 ++
infix  4 ==, /=, <, <=, >=, >
infixl 2 `bind`, `hcf`

-- Standard synonyms --------------------

type Rel a = a -> a -> Bool
type BinOp a = a -> a -> a

-- Standard type classes: -----------------------------------------------

class Eq a where
    (==), (/=) :: Rel a
    x /= y      = not (x == y)
-- (x == x) === True
-- (x == y) === (y == x)
-- (x == y) && (y == z) ==> (x == z)

class Eq a => Ord a where
    (<), (<=), (>), (>=) :: Rel a
    max, min             :: BinOp a

    x <  y            = x <= y && x /= y
    x >= y            = y <= x
    x >  y            = y < x

    max x y | x >= y  = x
            | y >= x  = y
    min x y | x <= y  = x
            | y <= x  = y

-- x <= x === True
-- (x <= y) && (y <= z) ==> (x <= z)

class Ord a => Ix a where
    range   :: (a,a) -> [a]
    index   :: (a,a) -> a -> Int
    inRange :: (a,a) -> a -> Bool

class Ord a => Enum a where
    enumFrom       :: a -> [a]              -- [n..]
    enumFromThen   :: a -> a -> [a]         -- [n,m..]
    enumFromTo     :: a -> a -> [a]         -- [n..m]
    enumFromThenTo :: a -> a -> a -> [a]    -- [n,n'..m]

    enumFromTo n m        = takeWhile (m>=) (enumFrom n)
    enumFromThenTo n n' m = takeWhile ((if n'>=n then (>=) else (<=)) m)
                                      (enumFromThen n n')

class LeftMul a b where
    (*) :: a -> b -> b

class Add a where
     (+),(-) :: BinOp a
     negate  :: a -> a
     zero    :: a
     negate x = zero - x
-- x + (y + z) === (x + y) + z
-- x + y === y + x
-- zero + x === x
-- x + zero === x
-- x - x === zero

class LeftMul a a => Mult a where
     unit     :: a
     (^)      :: a -> Int -> a
     x ^ 0     = unit
     x ^ 1     = x
     x ^ (2*n) = (x*x)^n
     x ^ (2*n+1) = x*(x*x)^n
-- x*(y*z) === (x*y)*z
-- unit*x === x

class Div a b where
     (/) :: a -> b -> a

class (Div a a, Add a, Mult a, Div a Int, LeftMul Int a) => Exp a where
     exp, log, cosh, sinh, tanh :: a -> a
     cosh x = (exp(x) + exp(-x))/2
     sinh x = (exp(x) - exp(-x))/2
     tanh x = (a-unit)/(a+unit) where a = exp(2*x)

class Functor f where
    map :: (a -> b) -> (f a -> f b)
-- map (u.v) === (map u).(map v)
-- map id === id

class Functor m => Monad m where
    result    :: a -> m a
    join      :: m (m a) -> m a
    bind      :: m a -> (a -> m b) -> m b
    join x     = bind x (\y->y)
    x `bind` f = join (map f x)
-- (map u).result === result.(map u)
-- (map u).join === join.(map (map u))
-- join.(map result) === id
-- join.result === id
-- join.join === join.(map join)

class Monad m => Monad0 m where
    nil   :: m a
-- map _ nil === nil
-- join nil === nil

class Monad0 c => MonadPlus c where
    (++) :: c a -> c a -> c a
-- nil ++ x === x
-- x ++ (y ++ z) === (x ++ y) ++ z

-- A trimmed down version of the Haskell Text class: ---------------------

type  ShowS   = String -> String

class Text a where
    showsPrec      :: Int -> a -> ShowS
    showList       :: [a] -> ShowS
    showsPrec       = primPrint
    showList []     = showString "[]"
    showList (x:xs) = showChar '[' . shows x . showl xs
                    where showl []     = showChar ']'
                          showl (x:xs) = showChar ',' . shows x . showl xs

shows      :: Text a => a -> ShowS
shows       = showsPrec 0

show       :: Text a => a -> String
show x      = shows x ""

showChar   :: Char -> ShowS
showChar    = (:)

showString :: String -> ShowS
showString  = (++)


-- Type class instances: -------------------------------------------

instance Eq ()  where () == () = True
instance Ord () where () <= () = True

instance Eq Int  where (==) = primEqInt

instance Ord Int where (<=) = primLeInt

instance Ix Int where
    range (m,n)      = [m..n]
    index (m,n) i    = primMinusInt i m
    inRange (m,n) i  = m <= i && i <= n

instance Enum Int where
    enumFrom n       = iterate (primPlusInt 1) n
    enumFromThen n m = iterate (primPlusInt (primMinusInt m n)) n

instance Eq Float where (==) = primEqFloat

instance Ord Float where (<=) = primLeFloat

instance Enum Float where
    enumFrom n       = iterate (primPlusFloat 1.0) n
    enumFromThen n m = iterate (primPlusFloat (primMinusFloat m n)) n

instance Eq Char  where (==) = primEqChar   -- c == d  =  ord c == ord d

instance Ord Char where (<=) = primLeChar   -- c <= d  =  ord c <= ord d

instance Ix Char where
    range (c,c')      = [c..c']
    index (c,c') ci   = primMinusInt (ord ci) (ord c)
    inRange (c,c') ci = ord c <= i && i <= ord c' where i = ord ci

instance Enum Char where
    enumFrom c        = [chr n | n <- [ord c .. 255]]
    enumFromThen c c' = [chr n | n <- [ord c, ord c' .. ord lastChar]]
              where lastChar = if c' < c then (chr 0) else (chr 255)

instance Eq a => Eq [a] where
    []     == []     =  True
    []     == (y:ys) =  False
    (x:xs) == []     =  False
    (x:xs) == (y:ys) =  x==y && xs==ys

instance Ord a => Ord [a] where
    []     <= _      =  True
    (_:_)  <= []     =  False
    (x:xs) <= (y:ys) =  x<y || (x==y && xs<=ys)

instance (Eq a, Eq b) => Eq (a,b) where
    (x,y) == (u,v)  =  x==u && y==v

instance (Eq a, Eq b, Eq c) => Eq (a,b,c) where
    (x,y,z) == (u,v,w) = x == u && y == v && z == w

instance (Ord a, Ord b) => Ord (a,b) where
    (x,y) <= (u,v)  = x<u  ||  (x==u && y<=v)

instance (Ord a, Ord b, Ord c) => Ord (a,b,c) where
    (x,y,z) <= (u,v,w) = x<u || (x == u && ( y<v || (y==v && z<=w)))

instance Eq Bool where
    True  == True   =  True
    False == False  =  True
    _     == _      =  False

instance Ord Bool where
    False <= x      = True
    True  <= x      = x

instance LeftMul Int Int where
   (*) = primMulInt

instance LeftMul Int Float where
   (*) n = primMulFloat(primIntToFloat n)

instance LeftMul Float Float where
   (*)  = primMulFloat

instance (LeftMul a b, LeftMul a c) => LeftMul a (b,c)
   where a * (b,c) = (a*b, a*c)

instance (LeftMul a b, LeftMul a c, LeftMul a d) => LeftMul a (b,c,d)
    where  a * (b,c,d) = (a*b, a*c, a*d)

instance LeftMul (a->a) (b->a)
     where (*) = (.)

instance Add Int
    where (+)    = primPlusInt
          (-)    = primMinusInt
          negate = primNegInt
          zero   = 0

instance Add Float
    where (+)    = primPlusFloat
          (-)    = primMinusFloat
          negate = primNegFloat
          zero = 0.0

instance (Add a, Add b) => Add (a,b)
    where  (a,b) + (a',b') = (a+a',b+b')
           (a,b) - (a',b') = (a-a',b-b')
           negate (a,b)    = (-a,-b)
           zero          = (zero,zero)

instance (Add a, Add b, Add c) => Add (a,b,c)
     where (a,b,c) + (a',b',c') = (a+a',b+b',c+c')
           (a,b,c) - (a',b',c') = (a-a',b-b',c-c')
           negate (a,b,c)       = (-a,-b,-c)
           zero               = (zero,zero,zero)

instance Add a => Add (b->a)
     where f + f' = \b -> (f b)+(f' b)
           f - f' = \b -> (f b)-(f' b)
           - f    = \b -> -(f b)
           zero = \b -> zero

instance Mult Int
    where  unit = 1

instance Mult Float
    where  unit = 1.0

instance Mult (a->a)
    where unit = \x -> x

instance Div Int Int
    where (/) = primDivInt

instance Div Float Float
    where (/) = primDivFloat

instance Div Float Int
    where x/n = x/(primIntToFloat n)

instance Exp Float
    where exp = primExpFloat
          log = primLogFloat

instance Functor   [] where map f []     = []
                            map f (x:xs) = f x : map f xs

instance Monad     [] where result x        = [x]
                            []     `bind` f = []
                            (x:xs) `bind` f = f x ++ (xs `bind` f)

instance Monad0    [] where nil         = []

instance MonadPlus [] where []     ++ ys = ys
                            (x:xs) ++ ys = x : (xs ++ ys)

instance Text () where
    showsPrec d ()    = showString "()"

instance Text Bool where
    showsPrec d True  = showString "True"
    showsPrec d False = showString "False"

instance Text Int where showsPrec = primShowsInt

instance Text Float where showsPrec = primShowsFloat

instance Text Char where
    showsPrec p c = showString [q, c, q] where q = '\''
    showList cs   = showChar '"' . showl cs
                    where showl ""       = showChar '"'
                          showl ('"':cs) = showString "\\\"" . showl cs
                          showl (c:cs)   = showChar c . showl cs

instance Text a => Text [a]  where
    showsPrec p = showList

instance (Text a, Text b) => Text (a,b) where
    showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .
                                       shows y . showChar ')'

----- standard list functions used in prelude ----------------

(!!)             :: [a] -> Int -> a    -- xs!!n selects the nth element of
(x:_)  !! 0       = x                  -- the list xs (first element xs!!0)
(_:xs) !! (n+1)   = xs !! n              -- for any n < length xs.

iterate          :: (a -> a) -> a -> [a] -- generate the infinite list
iterate f x       = x : iterate f (f x)  -- [x, f x, f (f x), ...

take                :: Int -> [a] -> [a]
take 0     _         = []
take _     []        = []
take (n+1) (x:xs)    = x : take n xs

takeWhile           :: (a -> Bool) -> [a] -> [a]
takeWhile p []       = []
takeWhile p (x:xs)
         | p x       = x : takeWhile p xs
         | otherwise = []

----- standard Boolean values used in prelude -------------------

otherwise :: Bool
otherwise = True

not :: Bool -> Bool
not True  = False
not False = True

------- standard arithmetic functions ------------------

abs :: (Add a, Ord a) => a -> a
abs x | x < zero  = -x
      | otherwise = x

signum :: (Add a, Ord a) => a -> Int
signum x | x > zero  = 1
         | x < zero  = -1
         | x == zero = 0

hcf :: BinOp Int
hcf x 0 = x
hcf x y = hcf y (x `mod` y)

sum :: Add a => [a] -> a
sum   []   = zero
sum (x:xs) = x + sum xs

product :: Mult a => [a] -> a
product   []   = unit
product (x:xs) = x*product xs

pi :: Float
pi  = 3.1415926535

------- standard combinators ----------------------

(.)            :: (b -> c) -> (a -> b) -> (a -> c)
(f . g) x       = f (g x)

id :: a -> a
id x = x

undefined         :: a
undefined | False  = undefined

----  Rationals -------------------------------------

data Rational = Int :/ Int

instance Eq Rational where
   (n :/ d) == (n' :/ d') = n*d' == n'*d

instance LeftMul Rational Rational where
   (n :/ d) * (n' :/ d') = lowest ((n*n') :/ (d*d'))

instance LeftMul Int Rational where
   m * (n :/ d) = lowest ((m*n) :/ d)

instance LeftMul Rational Float where
  (n :/ d) * x = n*(x/(primIntToFloat d))

instance Add Rational where
   (n :/ d) + (n' :/ d') = lowest ((n*d'+n'*d) :/ (d*d'))
   (n :/ d) - (n' :/ d') = lowest ((n*d'-n'*d) :/ (d*d'))
   negate (n :/ d)       = ((-n) :/ d)
   zero                  = 0 :/ 1

instance Mult Rational where
   unit = 1 :/ 1

instance Div Rational Int where
   (n :/ d) / m = lowest (n :/ (d*m))

instance Div Rational Rational where
   (n :/ d) / (n' :/ d') = lowest ((n*d') :/ (n'*d))

instance Div Float Rational where
    x / (n :/ d) = (d*x)/n

instance Ord Rational where
   (n :/ d) <= (n' :/ d') | d*d' > 0  = n*d' <= n'*d
                          | otherwise = n*d' >= n'*d

instance Enum Rational where
   enumFrom q       = iterate (\(n:/d)->(n+d):/d) q
   enumFromThen q r = iterate (+ (r-q)) q

instance Text Rational where
   showsPrec p (n :/ d) | d' == 1   = shows n'
                        | otherwise = shows n'.showChar '/'.shows d'
        where (n' :/ d') = lowest (n :/ d)

lowest (n :/ d) = (n/q) :/ (d/q) where q = (hcf n d)*(signum d)

------ Complexes -----------------------------------------------

data Gauss a = a :+! a

type Complex = Gauss Float

instance (Eq a) => Eq (Gauss a) where
   (x :+! y) == (x' :+! y') = (x==x') && (y==y')

instance (Mult a, Add a) => Mult (Gauss a) where
     unit = unit :+! zero

instance (Add a) => Add (Gauss a) where
  (x :+! y) + (x' :+! y') = (x+x') :+! (y+y')
  (x :+! y) - (x' :+! y') = (x-x') :+! (y-y')
  negate (x :+! y) = (-x) :+! (-y)
  zero = zero :+! zero

instance (LeftMul a b) => LeftMul a (Gauss b) where
    x * (y :+! z) = (x*y) :+! (x*z)

instance (LeftMul a b, Add b) => LeftMul (Gauss a) (Gauss b) where
  (x :+! y) * (x' :+! y') = (x*x' - y*y') :+! (x*y' + y*x')

instance Div a b => Div (Gauss a) b where
     (x :+! y)/d = (x/d) :+! (y/d)

instance (Div a b, Add a, Add b, LeftMul b a, LeftMul b b, LeftMul a a)
                                     => Div (Gauss a) (Gauss b)
        where z / z' = (x/d) :+! (y/d)
               where x       = u'*u+v'*v
                     y       = u'*v-v'*u
                     d       = u'*u'+v'*v'
                     u:+!v   = z
                     u':+!v' = z'

instance Exp Complex where
       exp (x :+! y) = let r = exp(x) in (r*cos(y)) :+! (r*(sin(y)))
       log (x :+! y) = let r=sqrt(x*x+y*y) in (log(r)) :+! (atan2 y x)

instance (Text a, Add a, Mult a, Ord a) => Text (Gauss a)
           where
 showsPrec n (x :+! y) | y == zero = shows x
                       | x == zero = showIm y
                       | y > zero    = shows x. showChar '+'. showIm y
                       | y < zero    = shows x. showChar '-'. showIm (-y)
         where showIm y | y == unit   = showChar 'i'
                        | y == (-unit) = showString "-i"
                        | otherwise    = shows y.showChar 'i'

norm :: (Add a, LeftMul a a) => (Gauss a) -> a
norm (x :+! y) = x*x + y*y

conjugate :: Add a => (Gauss a) -> (Gauss a)
conjugate (x :+! y) = x :+! (-y)

i :: (Add a, Mult a) => (Gauss a)
i = zero :+! unit

-- end of gcwmin ------------------------------------------------